perm filename EMACLS.2[MAC,LSP] blob
sn#570679 filedate 1981-03-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00019 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 MacLisp portion of the E/MacLisp Interface.
C00008 00003 From E to MacLisp
C00012 00004 (entry em:mail-type subr)
C00017 00005 (entry em:wait-mail subr)
C00018 00006 (entry em:mail-sfa subr)
C00019 00007 TYI
C00021 00008 TYO
C00022 00009 FORCE OUTPUT
C00024 00010 (entry rcc subr)
C00026 00011 This routine gets fresh mail to initialize the reader
C00028 00012 This routine does a jobread into the right spot.
C00030 00013 wait-ok
C00031 00014 (entry em:send-simple-message subr)
C00033 00015 (entry em:send-control-char subr)
C00035 00016 (entry em:initialize subr)
C00036 00017 send-ok
C00037 00018 (entry em:eval-protect subr)
C00038 00019 Storage for Mail routines
C00040 ENDMK
C⊗;
;;; MacLisp portion of the E/MacLisp Interface.
;;;
;;; An SFA/MAIL based system for communicating with
;;; an unstructured, standard text editor.
(declare (mapex t)
(special -em:jobnum-)
(fixnum -em:jobnum-))
(defun em:negotiate ()
(print 'waiting-for-mail)
(em:wait-mail)
(print 'got-mail)
(cond ((eq (em:get-mail) 'initiate)
(print 'initiate-received)
(print 'sending-reply)
(em:send-simple-message 'ok -em:jobnum-)
t)))
(defun em:toplevel ()
(let ((em:sfa (sfa-create (function em:mail-sfa) 0 'mail-sfa)))
(print 'Starting-negotiation)
(do () ((em:negotiate)))
(print 'Negotiation-complete)
(do ((message-type (progn (em:wait-mail)(print 'got-mail)
(prog2 () (em:get-mail)(print 'read-mail)))
(progn (em:wait-mail)(print 'got-mail)
(prog2 () (em:get-mail)(print 'read-mail)))))
(())
(print 'got-a-message)
(print (list 'message-type= message-type))
(*catch 'em:toplevel
(caseq message-type
(sexps
(em:eval-file em:sfa))
(control-chars
(em:eval-control-file em:sfa)))))))
(defun em:eval-file (sfa)
(setq -sfa- sfa)
(let ((eof (ncons ())))
(do ((form (read sfa eof)
(read sfa eof))
(ans))
((eq form eof) (print 'got-eof))
(print form)
(em:eval-protect)
(setq ans (errset (eval form)))
(em:eval-unprotect)
(cond (ans (print (car ans) sfa)
(print 'sent-answer)
(sfa-call sfa 'force-output ()))
(t (print 'error sfa)
(sfa-call sfa 'force-print ()))))))
(defun em:eval-control-file (sfa)
(print 'tyiing-control-chars)
(do ((char (tyi sfa -1)
(tyi sfa -1)))
((= char -1) t)
(print (list 'got-control-char char))
(caseq char
((#o302 #o342)
(break ↑B t))
((#o307 #o347)
(*throw 'em:toplevel t))
)))
(defun em:initiate-conversation (jobn)
(em:send-simple-message 'initiate jobn)
(let ((answer (em:wait-mail)))
(caseq answer
(ok t)
(t ()))))
(setq -sfa- ())
(defun init (n)
(setq -sfa- (sfa-create 'em:mail-sfa 0 'mail-sfa))
(em:send-simple-message 'initiate n)
(em:wait-mail) (em:get-mail))
(setq breakp ())
(defun em:force-print (x sfa)
(print x sfa)
(print 'printed)
(sfa-call sfa 'force-output ())
(print 'forced)(break force-print breakp)
(let ((eof (ncons ())))
(do ((form (read sfa eof)
(read sfa eof)))
((eq eof form) t)
(print form))))
(defun em:hold-it ()
(em:send-simple-message 'hold-it -em:jobnum-)
'hold-it-right-there!!!)
;;; From E to MacLisp
;;; Mail
;;; wd1: Job# sending message
;;; wd2: type of message
;;; 0,,1: SEXPs
;;; 0,,2 control (meta) chars to follow (E macro format)
;;; 0,,4: Ready for answer
;;; 0,,10: not ready for answer
;;; 0,,100: initiating a conversation
;;; 0,,200: interrupt. do <esc>i <char>
;;; 0,,400: close connection (suicide)
;;; 0,,1000: ok (did the jobread)
;;; 0,,2000: notok
;;; 1,,0: Continuation needed
;;; 2,,0: Short (fits in the next =30 words, ends with null byte
;;; or falls off)
;;; wd3: -number of words,,address of 1k buffer
;;;
;;; From MacLisp to E
;;; Mail
;;; wd1: Job#
;;; wd2: type of message
;;; 0,,1: Start of E commands
;;; 0,,2: Start of answer (PP text)
;;; 0,,4: Ready for answer?
;;; 0,,10: acknowledging a conversation initiation
;;; 0,,1000: ok (did the jobread)
;;; 0,,2000: notok
;;; 1,,0: Continuation needed
;;; 2,,0: Short
;;; wd3: -number of words,,address of 1k buffer
(lap em:get-mail subr)
(args em:get-mail (nil . 0))
(defsym alpha 2)
(defsym beta 3)
(defsym short-bit 2)
(defsym meta-mask 400)
(defsym kill-bit 400)
(defsym control-mask 200)
(defsym cont-bit 1)
(defsym sexp-bit 1)
(defsym control-bit 2)
(defsym ready-bit 4)
(defsym not-ready-bit 10)
(defsym initiate-bit 100)
(defsym interrupt-bit 200)
(defsym ok-bit 1000)
(defsym not-ok-bit 2000)
em:get-mail
(skipl 0 mailinp) ;-1 means mail in and not read
(mail 2 mailbox) ;SRCV
(jfcl)
(setzm 0 mailinp)
(setzm 0 tyi-inited)
(movei b 'nil)
(movem b (special sail-mail-interrupt))
(move tt mailbox) ;get the jobnum
(skipg 0 jobnum)
(jrst 0 gm1)
(came tt jobnum) ;correct one?
(jrst 0 false)
(movem tt jobread)
gm1 (movem tt jobnum)
(movem tt jobn2)
(jsp t fxcons) ;number cons
(movem a (special -em:jobnum-)) ;save it
(move tt (+ mailbox 1)) ;type bits
(jrst 0 em:mail-type)
true (movei a 't)
(popj p)
false (movei a 'nil)
(popj p)
(entry em:mail-type subr)
(args em:mail-type (nil . 0))
em:mail-type
(movei b 'nil)
(movem b (special -em:control-chars-))
(move tt (+ mailbox 1));type bits
(movei a 'nil) ;short flag
(tlne tt short-bit)
(movei a 't)
(movem a (special -em:shortp-))
(movei a 'nil)
(tlne tt cont-bit) ;continuation expected?
(movei a 't)
(movem a (special -em:continuation-))
(trne tt sexp-bit)
(jrst 0 sexps) ;sexps
(trne tt control-bit)
(jrst 0 cntrl) ;control chars
(trne tt ready-bit)
(jrst 0 ready) ;ready
(trne tt not-ready-bit)
(jrst 0 nready) ;not ready
(trne tt initiate-bit)
(jrst 0 initiate) ;initiate conversation
(trne tt interrupt-bit)
(jrst 0 interrupt) ;some interrupt
(trne tt ok-bit) ;ok
(jrst 0 ok)
(trne tt kill-bit) ;kill
(jrst 0 kill)
(trne tt not-ok-bit) ;not-ok
(jrst 0 not-ok)
(pushj p send-ok)
(movei a 'unknown)
(popj p)
sexps
(setzm 0 eofp) ;within eof
(skipe 0 inbytes)
(jrst 0 snot-finished)
sresume (move a (+ mailbox 2)) ;get number of bytes
(move tt (+ mailbox 1));type bits
(setzm 0 tyi-inited) ;tyi not inited
(hlrem a inbytes) ;store it
(setom 0 mailprocessed)
(tlne tt short-bit) ;short?
(jrst 0 tshort)
(pushj p transfer-buffer)
(movei a 'sexps)
(popj p)
tshort (pushj p transfer-short)
(movei a 'sexps)
(popj p)
cntrl
(setzm 0 eofp) ;within eof
(movei b 't)
(movem b (special -em:control-chars-))
(skipe 0 inbytes)
(jrst 0 cnot-finished)
cresume (setzm 0 tyi-inited) ;tyi not inited
(move tt (+ mailbox 1));type bits
(move a (+ mailbox 2)) ;get number of bytes
(hlrem a inbytes) ;store it
(setom 0 mailprocessed)
(tlne tt short-bit) ;short?
(jrst 0 tcshort)
(pushj p transfer-buffer)
(movei a 'control-chars)
(popj p)
tcshort (pushj p transfer-short)
(movei a 'control-chars)
(popj p)
ready (movei a 'ready)
(setom 0 mailprocessed)
(popj p)
nready (movei a 'not-ready)
(setom 0 mailprocessed)
(popj p)
initiate(movei a 'initiate)
(setom 0 mailprocessed)
(popj p)
interrupt
(movei a 'interrupt)
(setzm 0 mailprocessed)
(popj p)
not-ok
(movei a 'not-ok)
(setom 0 mailprocessed)
(popj p)
ok
(movei a 1) (ttyuuo 1 a)
(movei a 'ok)
(setzm 0 mailprocessed)
(popj p)
kill (pushj p send-ok)
(call 1 12) ;kill self
(entry snot subr)
snot-finished
(movei a 77)(ttyuuo 1 a)
(setzm 0 tyi-inited)
(movei a sresume)
(movem a resume-pc)
(movei a 'sexps)
(popj p)
(entry cnot subr)
cnot-finished
(movei a 77)(ttyuuo 1 a)
(setzm 0 tyi-inited)
(movei a cresume)
(movem a resume-pc)
(movei a 'control-chars)
(popj p)
(entry em:wait-mail subr)
(args em:wait-mail (nil . 0))
em:wait-mail
(722←33 0 mailint) ;imskcl
(mail 1 mailbox) ;WRCV
(721←33 0 mailint) ;imskst
(setom 0 mailprocessed) ;mail now in
(setom 0 mailinp) ;got mail
(movei a 't)
(popj p)
(entry em:mask-off subr)
(args em:mask-off (nil . 0))
(722←33 0 mailint) ;imskcl
(movei a 't)
(popj p)
(entry em:mask-on subr)
(args em:mask-on (nil . 0))
(721←33 0 mailint) ;imskst
(movei a 't)
(popj p)
(entry em:mail-sfa subr)
(args em:mail-sfa (nil . 3))
(movei a 0 b) ;operation type ignore the object
(caie a 'which-operations)
(jrst 0 t1)
(movei a '(tyi tyo force-output untyi))
(popj p)
t1 (cain a 'tyi) ;tyi?
(jrst 0 em:mail-tyi)
(cain a 'tyo) ;tyo?
(jrst 0 em:mail-tyo)
(cain a 'force-output) ;force output?
(jrst 0 em:mail-force-output)
(cain a 'untyi) ;untyi?
(jrst 0 em:mail-untyi)
(movei a 'nil)
(popj p)
;;; TYI
(entry em:mail-tyi)
em:mail-tyi
(movem c eofchar)
(skipe a (special -em:control-chars-))
(jrst 0 read-control-chars)
(skipe 0 untyif)
(jrst 0 untyi2)
(skipn 0 tyi-inited) ;not inited?
(pushj p real-mail-refresh)
(skipn 0 inbytes) ;and nothing left?
(pushj p mail-refresh)
tyi1 (aosle 0 inbytes)
(pushj p mail-refresh)
inmailok
(ildb tt inpoint) ;get byte
(skipe 0 tt) ;0 means end of file
(jrst 0 fix1) ;what a bum!
(pushj p mail-refresh)
(jrst 0 tyi1)
em:mail-untyi
(aos 0 untyif)
(move b untyipdl)
(push b c)
(movem b untyipdl)
(popj p)
untyi2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
reof
(setom 0 eofp)
(move a eofchar)
(sub p (% 0 0 1 1))
(popj p)
;;; TYO
em:mail-tyo
(move a @ c)
(idpb a outpoint) ;put it there
(sosg 0 outbytes) ;ready to send?
(pushj p mail-sendit)
(movei a 't)
(popj p)
;;; FORCE OUTPUT
em:mail-force-output
mail-sendit
(movei a 40) ;space
(idpb a outpoint)
(sos 0 outbytes) ;extra byte
(movei a outmail) ;address of buffer
(movem a (+ mailbox 2))
(move a outbytes)
(movei a #o5000)
(sub a outbytes)
(caile a 145.) ;short enough
(jrst 0 long-message) ;nope
(hrlzi tt outmail)
(hrri tt (+ mailbox 3))
(blt tt (+ mailbox 30.)) ;move to the right place
(hrli tt short-bit)
(jrst 0 send-message)
long-message
(hrli tt 0)
send-message
(hrri tt sexp-bit)
(movem tt (+ mailbox 1))
(movns 0 a)
(hrlzm a (+ mailbox 2))
(movei a outmail)
(hrrm a (+ mailbox 2))
(move a thisjob)
(movem a mailbox)
(pushj p wait-for-clear)
(mail 0 jobnum) ;mail it
(jrst 0 false)
(move a outpointtem) ;setup output byte count
(movem a outpoint)
(movei a #o5001))
(movem a outbytes)
(pushj p wait-ok) ;wait for acknowledgment
(pushj p em:mail-type)
(came a 'ok)
(jrst 0 false)
(jrst 0 true)
(entry rcc subr)
read-control-chars
(skipn 0 tyi-inited) ;tyi inited?
(pushj p real-mail-refresh)
(skipn 0 inbytes)
(pushj p mail-refresh)
(pushj p rgetchar)
(cain t alpha)
(movei tt control-mask) ;saw an α
(jrst 0 read-meta) ;now maybe a β?
(cain t beta) ;saw a β, so now the char
(iori t meta-mask)
read-char
(pushj p rgetchar)
(ior tt t)
(jrst 0 fix1)
read-meta
(pushj p rgetchar)
(cain t beta)
(iori t meta-mask)
(jrst 0 (+ read-char 1))
rgetchar(skipe 0 untyif)
(jrst 0 runty2)
(aosle 0 inbytes)
(pushj p mail-refresh)
(ildb t inpoint)
(skipe 0 t)
(cain t 40) ;space?
(jrst 0 rgetchar) ;foo, go around
(popj p)
rceof (move a eofchar)
(sub p (% 0 0 1 1))
(popj p)
runty2 (move b untyipdl)
(sosl 0 untyif)
(pop b a)
(movem b untyipdl)
(popj p)
;;; This routine gets fresh mail to initialize the reader
mail-refresh
(skipn 0 eofp)
(jrst 0 reof)
real-mail-refresh
(skipn 0 mailprocessed) ;processed?
(jrst 0 mr1) ;get the next batch
mr3 (pushj p em:wait-mail) ;wait for response
(jrst 0 em:get-mail) ;get the mail
mr1 (skipn 0 resume-pc) ;ready for crock?
(jrst 0 mr3) ;nope
(pushj p @ resume-pc) ;get the rest
(popj p) ;continue
;;; This routine does a jobread into the right spot.
transfer-buffer
(move a inpointtem) ;byte pointer template
(movem a inpoint)
(setom 0 tyi-inited) ready to read
(movei tt jobread)
(move a (+ mailbox 2))
(movem a (+ jobread 1))
(calli tt 400050) ;jobrd
(jrst 0 false)
(jrst 0 send-ok)
(popj p) ;good return
wait-ok
(movei tt 55)(ttyuuo 1 tt)
(722←33 0 mailint) ;imskcl
(mail 1 mailbox) ;WRCV
(721←33 0 mailint) ;imskst
(move tt (+ mailbox 2))
(setzm 0 mailinp)
(trnn tt ok-bit)
(jrst 0 true)
(jrst 0 false)
(entry em:send-simple-message subr)
(args em:send-simple-message (nil . 2))
(cain a 'initiate)
(jrst 0 initiate-message)
(cain a 'ok)
(jrst 0 ok-message)
(cain a 'not-ok)
(jrst 0 not-ok-message)
(cain a 'ready)
(jrst 0 ready-message)
(cain a 'not-ready)
(jrst 0 not-ready-message)
(cain a 'hold-it)
(jrst 0 hold-it-message)
(movei a 'Invalid-message)
(popj p)
initiate-message
(movei a initiate-bit)
(jrst 0 send-simple-message)
ok-message
(movei a 136)(ttyuuo 1 a)
(movei a ok-bit)
(jrst 0 send-simple-message)
not-ok-message
(movei a not-ok-bit)
(jrst 0 send-simple-message)
ready-message
(movei a ready-bit)
(jrst 0 send-simple-message)
hold-it-message
(movei a 102)
(movem a (+ mailb2 2))
(movei a interrupt-bit)
(jrst 0 send-simple-message)
not-ready-message
(movei a not-ready-bit)
send-simple-message
(movem a (+ mailb2 1))
(move b 0 b)
(movem b jobn2)
(movem b jobnum)
(move b thisjob)
(movem b mailb2)
(movem b mailbox)
(pushj p wait-for-clear)
(mail 0 jobn2)
(jrst 0 false)
(jrst 0 true)
wait-for-clear
(mail 4 jobnum)
(popj p)
(setz tt)
(calli tt 31)
(jrst 0 wait-for-clear)
(entry em:send-control-char subr)
(args em:send-control-char (nil . 2))
send-control-char
(movei t -1) ;count
(move tt outchartem)
(move a 0 a) ;get character
(trze a 200) ;control bit
(pushj p c1) ;push control
(trze a 400) ;meta bit
(pushj p m1) ;push meta
(idpb a tt)
(movei a control-bit)
(hrli a short-bit) ;short control chars
(movem a (+ mailb2 1))
(hrlzm t (+ mailb2 2))
(movei a outmail)
(hrrm a (+ mailb2 2))
(move b 0 b)
(movem b jobn2)
(movem b jobnum)
(move b thisjob)
(movem b mailb2)
(movem b mailbox)
(pushj p wait-for-clear)
(mail 0 jobn2)
(jrst 0 false)
(jrst 0 true)
c1 (movei r 2) ;alpha
(idpb r tt) ;send it
(sos 0 t) ;decrement
(popj p)
m1 (movei r 3) ;beta
(idpb r tt) ;send it
(sos 0 t) ;decrement
(popj p)
(entry em:initialize subr)
(args em:initialize (nil . 0))
(setzm 0 mailinp)
(setom 0 jobnum)
(calli tt 30)
(movem tt thisjob)
(jrst 0 fix1)
transfer-short
(move a inpointtem) ;byte pointer template
(movem a inpoint)
(hrlzi a (+ mailbox 3)) ;move from here
(hrri a inmail) ;to here
(blt a (+ inmail 30.)) ;transfer 30
(setom 0 tyi-inited) ;ready to read
(jrst 0 send-ok)
send-ok
(movei a 136)(ttyuuo 1 a)
(movei a ok-bit)
(movem a (+ mailb2 1))
(move b thisjob)
(movem b mailb2)
(pushj p wait-for-clear)
(mail 0 jobn2)
(jrst 0 false)
(jrst 0 true)
(entry em:eval-protect subr)
(args em:eval-protect (nil . 0))
(movei a mailbox)
(movem a (special sail-mail-address))
(movei a 't)
(popj p)
(entry em:eval-unprotect subr)
(args em:eval-unprotect (nil . 0))
(movei a 'nil)
(movem a (special sail-mail-address))
(popj p)
;;; Storage for Mail routines
eofp (-1) ;-1 means mail in and not read
mailinp (0) ;-1 means mail in and not read
mailint (4000000000)
jobnum (0)
(0 0 mailbox)
(entry mailbox subr)
mailbox (block 32.) ;mail
jobn2 (0)
(0 0 mailb2)
(entry mailb2 subr)
mailb2(block 32.) ;short mail
(entry inmail subr)
inmail (block 1000) ;text
(entry outmail subr)
outmail (block 1000) ;text
stack (block 20)
untyipdl (777760←22 0 stack)
untyif (0)
(entry inpoint subr)
inpoint (700←22 0 (- inmail 1))
inpointtem (700←22 0 (- inmail 1))
inbytes (0)
outpoint (700←22 0 (- outmail 1))
outpointtem (700←22 0 (- outmail 1))
outchartem (700←22 0 (+ mailb2 2))
outbytes (5001)
control-chars (0)
mailprocessed (-1) ;0 means not processed
tyi-inited (0) ;ready to read. 0 = nil, -1 = t
resume-pc (0) ;where to get more chars
eofchar (0) ;eof char
thisjob (0)
jobread (0)
(0)
(0 0 inmail)
()
(em:initialize)